Celestin Apprentice 7/Apprentice-Release7.iso/Source Code/Libraries/SAT 2.4.0/SAT/Add-ons/Graphic effects/GammaFade.p

Text File | 1996-12-28 | 13.1 KB | 429 lines | [TEXT/PJMM]

unit GammaFade;

{--------------------------------------------------------------------------------------------------------------- }
{ File "gamma.p" - Source for Altering the Gamma Tables of GDevices from Gamma.c                                 }
{   Last updated 6/29/95, MJS                                                                                     }
{--------------------------------------------------------------------------------------------------------------- }
{    7-13-95    ported to pascal  by Matthew Xavier Mora [e-mail]                                         }
{     7-18-95     fixed all the porting bugs and got it to work in think pascal                                     }
{----------------------------------------------------------------------------------------------------------------}
{     7-18-95 ported to CW (68k and PPC) by Bill Catambay (pretty easy), cleaned the code a bit (no more labels),     }
{           brought back Matthew's delay fade routines (in main program).                                             }
{----------------------------------------------------------------------------------------------------------------}
{    august -95: Change by Ingemar R: Moved the FadeToBlack and FadeFromBlack calls to}
{        this unit and modified them to be timed by TickCount and aborted by mouse clicks.}
{        DoGammaFade now auto-initializes - no call to SetupGammaTools is needed.}
{        You can use FadeToBlack and FadeFromBlack only. They both check for gamma tables}
{        to be available, so you don't have to call IsGammaAvailable yourself.}
{        These changes were made when making a SAT add-on unit of it.}


{---------------------------------------------------------------------------------------------------------------}
{    This is the Source Code for the Gamma Utils Library file. Use this to build                                    }
{        new functionality into the library or make an A4-based library.                                         }
{    See the header file "gamma.h" for much more information. -- MJS                                                }
{---------------------------------------------------------------------------------------------------------------}

interface

    uses
{$IFC UNDEFINED THINK_PASCAL}
        Types, QuickDraw, Fonts, Events, Packages, Menus, Dialogs, Windows,{}
        OSUtils, ToolUtils, Resources, Memory, Devices, Files,
{$ENDC}
        Traps, Video;

{ Function Prototypes}

    function IsGammaAvailable: Boolean;
    function IsOneGammaAvailable (theGDevice: GDHandle): Boolean;

{    These routines help you determine whether you can use the Gamma Table Utils}
{        on the current machine. The first checks all attached monitors, and the }
{        second just checks the indicated monitor. Each returns TRUE if you can }
{        use the functions, or FALSE if you can't. • Note: Before calling any other}
{        Gamma Table function below, use this function to see if you are allowed.}

{ * ****************************************************************************** *}

    function SetupGammaTools: OSErr;
    function DisposeGammaTools: OSErr;

{    These routines must bracket any calls to the Gamma Table functions, perhaps}
{        at the head and tail of your main(). The first sets up the data structures}
{        necessary to save and restore the state of your monitors. The second}
{        disposes of all the internal data structures, but does not reset the}
{        monitors to their original states. Both return the error code if some}
{        part failed. }

{ * ****************************************************************************** *}

    function DoGammaFade (percent: Integer): OSErr;
    function DoOneGammaFade (theGDevice: GDHandle; percent: Integer): OSErr;


{    Use the first function to Fade each of your monitors to some percentage of their}
{        initial brightness (100 = bright, 0 = dim). Repeatedly call this to ramp your}
{        monitors up or down. The second function performs the same function, but only}
{        for the specified monitor. Both return any applicable error codes.}
{    Be sure to set up the necessary save-state data structures before you start by}
{        calling the compatibility and initialization functions. }

{ * ****************************************************************************** *}

{function GetDevGammaTable (theGDevice: GDHandle; var theTable: GammaTblPtr): OSErr;}
{function SetDevGammaTable (theGDevice: GDHandle; var theTable: GammaTblPtr): OSErr;}


{    These routines are low-level interfaces to the device drivers for the monitors.}
{        Use them at your own risk.}
{NO LONGER EXPORTED! /Ingemar}


{Quick fixed-time calls:}

    procedure FadeToBlack (ticks: Longint);
    procedure FadeFromBlack (ticks: Longint);


implementation

    const
        kGammaUtilsSig = 'GAMA';
        kGetDeviceListTrapNum = $AA29;

    type
        GlobalGammasPtr = ^GlobalGammas;
        GlobalGammasHdl = ^GlobalGammasPtr;
        GlobalGammas = record
                size, dataOffset: Integer;
                saved, hacked: GammaTblHandle;
                theGDevice: GDHandle;
                next: GlobalGammasHdl;
            end;
        GammaData = packed array[0..100000] of Byte;  {used to set the gamma}
        GammaDataPtr = ^GammaData;

    var
        gammaUtilsInstalled: OSType;
        gammaTables: GlobalGammasHdl;

    function GetDevGammaTable (theGDevice: GDHandle; var theTable: GammaTblPtr): OSErr;
    forward;
    function SetDevGammaTable (theGDevice: GDHandle; var theTable: GammaTblPtr): OSErr;
    forward;



{Fixed-time fading routines that can be aborted with a mouse click.}

    procedure FadeToBlack (ticks: Longint);
        var
            i: integer;
            oe: OSErr;
            startTicks: Longint;
    begin
        if not IsGammaAvailable then
            Exit(FadeToBlack);
        startTicks := TickCount;
        while TickCount < startTicks + ticks do
            begin
                i := 100 * (startTicks + ticks - TickCount) div ticks;
                oe := DoGammaFade(i);

                if Button then
                    begin
                        oe := DoGammaFade(0);
                        Exit(FadeToBlack);
                    end;
            end;
        oe := DoGammaFade(0);
    end; {FadeToBlack}

    procedure FadeFromBlack (ticks: Longint);
        var
            i: integer;
            oe: OSErr;
            startTicks: Longint;
    begin
        if not IsGammaAvailable then
            Exit(FadeFromBlack);
        startTicks := TickCount;
        while TickCount < startTicks + ticks do
            begin
                i := 100 - 100 * (startTicks + ticks - TickCount) div ticks;
                oe := DoGammaFade(i);

                if Button then
                    begin
                        oe := DoGammaFade(100);
                        Exit(FadeFromBlack);
                    end;
            end;
        oe := DoGammaFade(100);
    end; {FadeFromBlack}




    function IsGammaAvailable: Boolean;
        var
            theGDevice: GDHandle;
    begin
        IsGammaAvailable := false;
        if (NGetTrapAddress(kGetDeviceListTrapNum, ToolTrap) = NGetTrapAddress(_Unimplemented, ToolTrap)) then
            exit(IsGammaAvailable);
        theGDevice := GetDeviceList;
        while (theGDevice <> nil) do
            begin
                if (TestDeviceAttribute(theGDevice, screenDevice) and TestDeviceAttribute(theGDevice, noDriver)) then
                    exit(IsGammaAvailable);
                if (theGDevice^^.gdType = fixedType) then
                    exit(IsGammaAvailable);
                theGDevice := GetNextDevice(theGDevice);
            end;
        IsGammaAvailable := true; {If we made it this far then its true}
    end;


    function IsOneGammaAvailable (theGDevice: GDHandle): Boolean;
    begin
        IsOneGammaAvailable := false;
        if (NGetTrapAddress(kGetDeviceListTrapNum, ToolTrap) = NGetTrapAddress(_Unimplemented, ToolTrap)) then
            exit(IsOneGammaAvailable);
        if (TestDeviceAttribute(theGDevice, screenDevice) and TestDeviceAttribute(theGDevice, noDriver)) then
            exit(IsOneGammaAvailable);
        if (theGDevice^^.gdType = fixedType) then
            exit(IsOneGammaAvailable);
        IsOneGammaAvailable := true;
    end;

    function SetupGammaTools: OSErr;
        var
            errorCold: OSErr;
            tempHdl: GlobalGammasHdl;
            masterGTable: GammaTblPtr;
            theGDevice: GDHandle;
    begin
        if (gammaUtilsInstalled = kGammaUtilsSig) then
            begin
                SetupGammaTools := -1;
                exit(SetupGammaTools);
            end;
        gammaTables := nil;
        gammaUtilsInstalled := kGammaUtilsSig;
        theGDevice := GetDeviceList;
        while (theGDevice <> nil) do
            begin
                errorCold := GetDevGammaTable(theGDevice, masterGTable);
                if (errorCold <> 0) then
                    begin
                        SetupGammaTools := errorCold;
                        exit(SetupGammaTools);
                    end;
                tempHdl := globalGammasHdl(NewHandle(sizeof(globalGammas)));
                if (tempHdl = nil) then
                    begin
                        SetupGammaTools := MemError;
                        exit(SetupGammaTools);
                    end;
                with masterGTable^ do
                    begin
                        tempHdl^^.size := sizeof(GammaTbl) + gFormulaSize + (gChanCnt * gDataCnt * gDataWidth div 8);
                        tempHdl^^.dataOffset := gFormulaSize;
                        tempHdl^^.theGDevice := theGDevice;
                    end;
                tempHdl^^.saved := GammaTblHandle(NewHandle(tempHdl^^.size));
                if (tempHdl^^.saved = nil) then
                    begin
                        SetupGammaTools := MemError;
                        exit(SetupGammaTools);
                    end;
                tempHdl^^.hacked := GammaTblHandle(NewHandle(tempHdl^^.size));
                if (tempHdl^^.hacked = nil) then
                    begin
                        SetupGammaTools := MemError;
                        exit(SetupGammaTools);
                    end;
                BlockMove(Ptr(masterGTable), Ptr(tempHdl^^.saved^), tempHdl^^.size);
                tempHdl^^.next := gammaTables;
                gammaTables := tempHdl;
                theGDevice := GetNextDevice(theGDevice)
            end;
        SetupGammaTools := 0;
    end;

    function DoGammaFade (percent: Integer): OSErr;
        var
            errorCold: OSErr;
            thesize, i, theNum: LongInt;
            tempHdl: GlobalGammasHdl;
            dataPtr: Ptr;
            tempGammaTbl: GammaTblPtr;
            gdp: GammaDataPtr;
            tempLong: Longint;
    begin
        if gammaUtilsInstalled <> kGammaUtilsSig then
            errorCold := SetupGammaTools;
        if gammaUtilsInstalled <> kGammaUtilsSig then
            begin
                DoGammaFade := -1;
                exit(DoGammaFade);
            end;
        tempHdl := gammaTables;
        while (tempHdl <> nil) do
            begin
                with tempHdl^^ do
                    begin
                        BlockMove(Ptr(saved^), Ptr(hacked^), size);
                        tempLong := ord(@hacked^^.gFormulaData) + dataOffset;
                        gdp := gammaDataPtr(ord(@hacked^^.gFormulaData) + dataOffset);
                        thesize := hacked^^.gChanCnt * hacked^^.gDataCnt;
                    end;
                for i := 0 to thesize - 1 do
                    begin
                        theNum := gdp^[i];
                        theNum := (theNum * percent) div 100;
                        gdp^[i] := theNum;
                    end;
                errorCold := SetDevGammaTable(tempHdl^^.theGDevice, tempHdl^^.hacked^);
                if (errorCold <> 0) then
                    begin
                        DoGammaFade := errorCold;
                        exit(DoGammaFade);
                    end;
                tempHdl := tempHdl^^.next;
            end;
        DoGammaFade := 0;
    end;

    function DoOneGammaFade (theGDevice: GDHandle; percent: Integer): OSErr;
        var
            errorCold: OSErr;
            thesize, i, theNum: LongInt;
            tempHdl: GlobalGammasHdl;
            gdp: GammaDataPtr;
    begin
        if gammaUtilsInstalled <> kGammaUtilsSig then
            errorCold := SetupGammaTools;
        if gammaUtilsInstalled <> kGammaUtilsSig then
            begin
                DoOneGammaFade := -1;
                Exit(DoOneGammaFade);
            end;
        tempHdl := gammaTables;
        while ((tempHdl <> nil) and (theGDevice <> tempHdl^^.theGDevice)) do
            tempHdl := tempHdl^^.next;
        with tempHdl^^ do
            begin
                BlockMove(Ptr(saved^), Ptr(hacked^), size);
                gdp := gammaDataPtr(ord(@hacked^^.gFormulaData) + dataOffset);
                thesize := hacked^^.gChanCnt * hacked^^.gDataCnt;
            end;
        for i := 0 to thesize - 1 do
            begin
                theNum := gdp^[i];
                theNum := (theNum * percent) div 100;
                gdp^[i] := theNum;
            end;
        errorCold := SetDevGammaTable(tempHdl^^.theGDevice, tempHdl^^.hacked^);
        DoOneGammaFade := errorCold;
    end;

    function DisposeGammaTools: OSErr;
        var
            tempHdl, nextHdl: GlobalGammasHdl;
    begin
        if gammaUtilsInstalled <> kGammaUtilsSig then
            begin
                DisposeGammaTools := -1;
                Exit(DisposeGammaTools);
            end;
        tempHdl := gammaTables;
        while (tempHdl <> nil) do
            begin
                HLock(Handle(tempHdl));
                with tempHdl^^ do
                    begin
                        nextHdl := next;
                        DisposeHandle(Handle(saved));
                        DisposeHandle(Handle(hacked));
                        HUnLock(Handle(tempHdl));
                        DisposeHandle(Handle(tempHdl));
                        tempHdl := nextHdl;
                    end;
            end;
        gammaUtilsInstalled := '    ';
        DisposeGammaTools := 0;
    end;

    function GetDevGammaTable (theGDevice: GDHandle; var theTable: GammaTblPtr): OSErr;
        var
            errorCold: OSErr;
            myCPB: ParmBlkPtr;
    begin
        theTable := nil;
        if not IsOneGammaAvailable(theGDevice) then
            begin
                GetDevGammaTable := -1;
                exit(GetDevGammaTable);
            end;
        myCPB := ParmBlkPtr(NewPtrClear(sizeof(ParamBlockRec)));
        if (myCPB = nil) then
            begin
                GetDevGammaTable := MemError;
                exit(GetDevGammaTable);
            end;
        myCPB^.csCode := cscGetGamma;
        myCPB^.ioCRefNum := theGDevice^^.gdRefNum;
        myCPB^.csParam[0] := HiWord(longint(@theTable));
        myCPB^.csParam[1] := LoWord(longint(@theTable));
{$IFC UNDEFINED THINK_PASCAL}
        errorCold := PBStatusSync(myCPB);
{$ELSEC}
        errorCold := PBStatus(myCPB, false);
{$ENDC}
        DisposePtr(Ptr(myCPB));
        GetDevGammaTable := errorCold;
    end;

    function SetDevGammaTable (theGDevice: GDHandle; var theTable: GammaTblPtr): OSErr;
        var
            myCPB: ParmBlkPtr;
            errorCold: OSErr;
            cTab: CTabHandle;
            saveGDevice: GDHandle;
    begin
        if not IsOneGammaAvailable(theGDevice) then
            begin
                SetDevGammaTable := -1;
                exit(SetDevGammaTable);
            end;
        myCPB := ParmBlkPtr(NewPtrClear(sizeof(ParamBlockRec)));
        if (myCPB = nil) then
            begin
                SetDevGammaTable := MemError;
                exit(SetDevGammaTable);
            end;
        myCPB^.csCode := cscSetGamma;
        myCPB^.ioCRefNum := theGDevice^^.gdRefNum;
        myCPB^.csParam[0] := HiWord(longint(@theTable));
        myCPB^.csParam[1] := LoWord(longint(@theTable));
{$IFC UNDEFINED THINK_PASCAL}
        errorCold := PBControlSync(myCPB);
{$ELSEC}
        errorCold := PBControl(myCPB, false);
{$ENDC}
        if (errorCold = 0) then
            begin
                saveGDevice := GetGDevice;
                SetGDevice(theGDevice);
                cTab := theGDevice^^.gdPMap^^.pmTable;
                SetEntries(0, cTab^^.ctSize, cTab^^.ctTable);
                SetGDevice(saveGDevice);
            end;
        DisposePtr(Ptr(myCPB));
        SetDevGammaTable := errorCold;
    end;

end.